home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / smaltalk.lha / smalltalk-1.1.1 / stix / XPacket.st < prev   
Text File  |  1991-09-12  |  10KB  |  486 lines
  1. "======================================================================
  2. |
  3. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  4. | Written by Steve Byrne.
  5. |
  6. | This file is part of GNU Smalltalk.
  7. |
  8. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  9. | under the terms of the GNU General Public License as published by the Free
  10. | Software Foundation; either version 1, or (at your option) any later version.
  11. | 
  12. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  13. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15. | details.
  16. | 
  17. | You should have received a copy of the GNU General Public License along with
  18. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  19. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  20. |
  21.  ======================================================================"
  22.  
  23.  
  24. "
  25. |     Change Log
  26. | ============================================================================
  27. | Author       Date       Change 
  28. | sbyrne     24 May 90      created.
  29. |
  30. "
  31.  
  32. Object subclass: #XPacket
  33.        instanceVariableNames: 'stream pos values'
  34.        classVariableNames: 'EventNames PointerEventNames DeviceEventNames
  35.                             KeyButMaskNames KeyMaskNames WinGravityNames
  36.                             BitGravityNames'
  37.        poolDictionaries: ''
  38.        category: 'X hacking'
  39. !
  40.  
  41. XPacket subclass: #XWindowAttrPacket
  42.     instanceVariableNames: ''
  43.     classVariableNames: ''
  44.     poolDictionaries: ''
  45.     category: 'X window attributes'
  46. !
  47.  
  48. XPacket subclass: #XConfigPacket
  49.     instanceVariableNames: ''
  50.     classVariableNames: ''
  51.     poolDictionaries: ''
  52.     category: 'X window configuration'
  53. !
  54.  
  55. XPacket subclass: #XGCAttrPacket
  56.     instanceVariableNames: ''
  57.     classVariableNames: ''
  58.     poolDictionaries: ''
  59.     category: 'X graphic context attributes'
  60. !
  61.  
  62.  
  63. Smalltalk at: #ShowPacket put: false!
  64.  
  65.  
  66. !XPacket class methodsFor: 'instance creation'!
  67.  
  68. command: aByte
  69.     ^self command: aByte aux: 0
  70. !
  71.  
  72. command: aByte aux: aByte2
  73.     ^(self new) init: aByte aux: aByte2
  74. !
  75.  
  76. initialize
  77.     EventNames _ #(KeyPress KeyRelease ButtonPress ButtonRelease EnterWindow
  78.                LeaveWindow PointerMotion PointerMotionHint
  79.                Button1Motion Button2Motion Button3Motion Button4Motion
  80.                Button5Motion ButtonMotion KeymapState Exposure
  81.                VisibilityChange StructureNotify ResizeRedirect
  82.                SubstructureNotify SubstructureRedirect FocusChange
  83.                PropertyChange ColormapChange OwnerGrabButton).
  84.     PointerEventNames _ EventNames copy.
  85.     self remove: #(KeyPress KeyRelease Exposure
  86.                VisibilityChange StructureNotify ResizeRedirect
  87.                SubstructureNotify SubstructureRedirect FocusChange
  88.                PropertyChange ColormapChange OwnerGrabButton)
  89.      from: PointerEventNames.
  90.     DeviceEventNames _ EventNames copy.
  91.     self remove: #(KeyPress KeyRelease Exposure
  92.                VisibilityChange StructureNotify ResizeRedirect
  93.                SubstructureNotify SubstructureRedirect FocusChange
  94.                PropertyChange ColormapChange OwnerGrabButton)
  95.      from: PointerEventNames.
  96.     DeviceEventNames _ EventNames copy.
  97.     self remove: #(EnterWindow LeaveWindow PointerMotionHint
  98.                KeymapState Exposure
  99.                VisibilityChange StructureNotify ResizeRedirect
  100.                SubstructureNotify SubstructureRedirect FocusChange
  101.                PropertyChange ColormapChange OwnerGrabButton)
  102.      from: DeviceEventNames.
  103.  
  104.     KeyMaskNames _ #(Shift Lock Control Mod1 Mod2 Mod3 Mod4 Mod5).
  105.     KeyButMaskNames _ KeyMaskNames, #(Button1 Button2 Button3 Button4 Button5).
  106.  
  107.     BitGravityNames _ #(Forget NorthWest North NorthEast
  108.                 West Center East SouthWest
  109.                 South SouthEast Static).
  110.     WinGravityNames _ BitGravityNames copy.
  111.     WinGravityNames at: 1 put: #Unmap.
  112. !
  113.  
  114. remove: anArray from: eventNames
  115.     1 to: eventNames size do:
  116.     [ :i | (anArray includes: (eventNames at: i))
  117.            ifTrue: [ eventNames at: i put: nil ] ]
  118. !!
  119.  
  120. XPacket initialize!        "Temp: make sure to do this"
  121.  
  122.  
  123. !XPacket methodsFor: 'accessing'!
  124.  
  125. done
  126.     ^self done: false
  127. !
  128.  
  129. doneWord
  130.     ^self done: true
  131. !
  132.  
  133. done: isWord
  134.     | length |
  135.     self pad.
  136.     values notNil
  137.     ifTrue: [ self emitBitValues: isWord ].
  138.     length _ stream position // 4.
  139.     stream position: 3.
  140.     self word: length.
  141.     ShowPacket ifTrue:
  142.     [ stream contents printNl ].
  143.     ^stream contents    
  144. !
  145.  
  146. emitBitValues: isWord
  147.     | bitMask |
  148.     bitMask _ 0.
  149.     values inject: 1 into: 
  150.     [ :bit :value | value notNil
  151.                 ifTrue: [ bitMask _ bitMask bitOr: bit ].
  152.             bit * 2 ].
  153.     isWord
  154.     ifTrue: [ self uword: bitMask ]
  155.     ifFalse: [ self ulong: bitMask ].
  156.     values do: [ :value | value notNil
  157.                   ifTrue: [ self long: value ] ]
  158. !
  159.  
  160. byte: aByte
  161.     stream nextPut: aByte
  162. !
  163.  
  164. bool: aBool
  165.     aBool            "### May extend this to support #True & #False"
  166.     ifTrue: [ stream nextPut: 1 ]
  167.     ifFasle:[ stream nextPut: 0 ]
  168. !
  169.  
  170. word: aWord
  171.     Bigendian 
  172.     ifTrue: [ stream nextPut: aWord // 256. 
  173.           stream nextPut: (aWord bitAnd: 255) ]
  174.     ifFalse: [ stream nextPut: (aWord bitAnd: 255).
  175.            stream nextPut: aWord // 256 ]
  176. !
  177.  
  178. uword: aWord
  179.     self word: aWord        "hack for now"
  180. !
  181.  
  182. long: aLong
  183.     Bigendian 
  184.     ifTrue: [ self word: aLong // 65536. 
  185.           self word: (aLong bitAnd: 65535) ]
  186.     ifFalse: [ self word: (aLong bitAnd: 65535).
  187.            self word: aLong // 65536 ]
  188. !
  189.  
  190. ulong: aLong
  191.     self long: aLong        "hack for now"
  192. !
  193.  
  194. bytes: byteArray
  195.     stream nextPutAll: byteArray
  196. !
  197.  
  198.  
  199. point: aPoint
  200.     self word: aPoint x.
  201.     self word: aPoint y
  202. !
  203.  
  204. rectangle: aRectangle
  205.     self point: aRectangle origin.
  206.     self point: aRectangle corner
  207. !
  208.  
  209. arc: anArc
  210.     anArc emitTo: self
  211. !
  212.  
  213. pad
  214.     | curPos numBytes |
  215.     curPos _ stream position.
  216.     numBytes _ 4 - (curPos - 1) bitAnd: 3.
  217.  
  218.     stream next: numBytes put: 0 
  219. !!
  220.  
  221. !XWindowAttrPacket methodsFor: 'variable arity requests'!
  222.  
  223.  
  224. backgroundPixmap: aValue
  225.     self at: 1 ulong: (X maybeMap: aValue into: #(None ParentRelative))
  226. !
  227.  
  228. backgroundPixel: aValue
  229.     self at: 2 ulong: aValue
  230. !
  231.  
  232. borderPixmap: aValue
  233.     self at: 3 ulong: (X maybeMap: aValue into: #(CopyFromParent))
  234. !
  235.  
  236. borderPixel: aValue
  237.     self at: 4 ulong: aValue
  238. !
  239.  
  240. bitGravity: aValue
  241.     self at: 5
  242.     self byte: (X map: aValue into: BitGravityNames)
  243. !
  244.  
  245. winGravity: aValue
  246.     self at: 6 byte: (X map: aValue into: WinGravityNames) 
  247. !
  248.  
  249. backingStore: aValue
  250.     self at: 7 byte: (X map: aValue into: #(NotUseful WhenMapped Always))
  251. !
  252.  
  253. backingPlanes: aValue
  254.     self at: 8 ulong: aValue
  255. !
  256.  
  257. backingPixel: aValue
  258.     self at: 9 ulong: aValue
  259. !
  260.  
  261. overrideRedirect: aValue
  262.     self at: 10 bool: aValue
  263. !
  264.  
  265. saveUnder: aValue
  266.     self at: 11 bool: aValue
  267. !
  268.  
  269. eventMask: aValue
  270.     self at: 12 ulong: (self makeBitmask: aValue using: EventNames)
  271. !    
  272.  
  273.  
  274. doNotPropagateMask: aValue
  275.     self at: 13 ulong: (self makeBitmask: aValue using: DeviceEventNames)
  276. !
  277.  
  278. colormap: aValue
  279.     self at: 14 ulong: (X maybeMap: aValue into: #(CopyFromParent))
  280. !
  281.  
  282. cursor: aValue
  283.     self at: 15 ulong: (X maybeMap: aValue into: #(None))
  284. !!
  285.  
  286.  
  287. !XConfigPacket methodsFor: 'variable arity request'!
  288.  
  289. x: aValue
  290.     self at: 1 word: aValue
  291. !
  292.  
  293. y: aValue
  294.     self at: 2 word: aValue
  295. !
  296.  
  297. width: aValue
  298.     self at: 3 uword: aValue
  299. !
  300.  
  301. height: aValue
  302.     self at: 4 uword: aValue
  303. !
  304.  
  305. borderWidth: aValue
  306.     self at: 5 uword: aValue
  307. !
  308.  
  309. sibling: aValue
  310.     self at: 6 ulong: aValue id
  311. !
  312.  
  313. stackMode: aValue
  314.     self at: 7 byte: (X map: aValue into: #(Above Below TopIf BottomIf Opposite))
  315. !!
  316.  
  317.  
  318. !XGCAttrPacket methodsFor: 'variable arity requests'!
  319.  
  320. "GC related requests"
  321.  
  322. function: aValue
  323.     self at: 1 
  324.      byte: (X map: aValue
  325.           into: #(Clear And AndReverse Copy AndInverted
  326.                   NoOp Xor Or Nor Equiv Invert
  327.                   OrReverse CopyInverted OrInverted
  328.                   Nand Set))
  329. !
  330.     
  331. planeMask: aValue
  332.     self at: 2 ulong: aValue
  333. !
  334.  
  335. foreground: aValue
  336.     self at: 3 ulong: aValue
  337. !
  338.  
  339. background: aValue
  340.     self at: 4 ulong: aValue
  341. !
  342.  
  343. lineWidth: aValue
  344.     self at: 5 uword: aValue
  345. !
  346.  
  347. lineStyle: aValue
  348.     self at: 6 byte: (X map: aValue into: #(Solid OnOffDash DoubleDash))
  349. !
  350.  
  351. capStyle: aValue
  352.     self at: 7 byte: (X map: aValue into: #(NotLast Butt Round Projecting))
  353. !
  354.  
  355. joinStyle: aValue
  356.     self at: 8 byte: (X map: aValue into: #(Miter Round Bevel))
  357. !
  358.  
  359. fillStyle: aValue
  360.     self at: 9 byte: (X map: aValue into: #(Solid Tiled Stippled OpaqueStippled))
  361. !
  362.  
  363. fillRule: aValue
  364.     self at: 10 byte: (X map: aValue into: #(NotLast Butt Round Projecting))
  365. !
  366.  
  367. tile: aValue
  368.     self at: 11 ulong: aValue id
  369. !
  370.  
  371. stipple: aValue
  372.     self at: 12 ulong: aValue id
  373. !
  374.  
  375. tileStippleXOrigin: aValue
  376.     self at: 13 word: aValue
  377. !
  378.  
  379. tileStippleYOrigin: aValue
  380.     self at: 14 word: aValue
  381. !
  382.  
  383. font: aValue
  384.     self at: 15 ulong: aValue id
  385. !
  386.  
  387. subwindowMode: aValue
  388.     self at: 16 byte: (X map: aValue into: #(ClipByChildren IncludeInferiors))
  389. !
  390.  
  391. graphicsExposures: aValue
  392.     self at: 17 bool: aValue
  393. !
  394.  
  395. clipXOrigin: aValue
  396.     self at: 18 word: aValue
  397. !
  398.  
  399. clipYOrigin: aValue
  400.     self at: 19 word: aValue
  401. !
  402.  
  403.  
  404. clipMask: aValue
  405.     self at: 20 ulong: (X maybeMap: aValue into: #(None))
  406. !
  407.  
  408. dashOffset: aValue
  409.     self at: 21 uword: aValue
  410. !
  411.  
  412. dashes: aValue
  413.     self at: 22 ubyte: aValue
  414. !
  415.  
  416. arcMode: aValue
  417.     self at: 23 byte: (X map: aValue into: #(Chord PieSlice))
  418. !!
  419.  
  420.  
  421. !XPacket methodsFor: 'variable arity support'!
  422.  
  423.  
  424. at: index byte: aValue
  425.     ^self at: index long: aValue
  426. !
  427.  
  428. at: index bool: aValue
  429.     ^self at: index 
  430.       long: [ aValue ifTrue: [ 1 ] ifFalse: [ 0 ] ]
  431. !
  432.  
  433. at: index ubyte: aValue
  434.     ^self at: index long: aValue
  435. !
  436.  
  437. at: index word: aValue
  438.     ^self at: index long: aValue
  439. !
  440.  
  441. at: index uword: aValue
  442.     ^self at: index long: aValue
  443. !
  444.  
  445. at: index ulong: aValue
  446.     ^self at: index long: aValue
  447. !
  448.  
  449. at: index long: aValue
  450.     values isNil ifTrue: [ values _ Array new: 32 ]. "large enough"
  451.     values at: index put: aValue
  452. !
  453.  
  454.  
  455. noBits
  456.     values _ Array new: 32
  457. !
  458.  
  459. makeBitmask: symArray using: nameArray
  460.     | bits | 
  461.     bits _ 0.
  462.     symArray do: [ :sym | bits _ bits bitOr: 
  463.                   (1 bitShift: (X map: sym into: nameArray)) ].
  464.     ^bits
  465. ! !
  466.  
  467.     
  468.  
  469. !XPacket methodsFor: 'writing'!
  470.  
  471. textItem: aTextItem
  472.     aTextItem emitTo: self
  473. !!
  474.  
  475.  
  476.  
  477. !XPacket methodsFor: 'private'!
  478.  
  479. init: aByte aux: aByte2
  480.     stream _ ReadWriteStream on: (ByteArray new: 0).
  481.     self byte: aByte.
  482.     self byte: aByte2.
  483.     self word: 0        "placeholder for length"
  484. !!
  485.  
  486.